Como encontrar as cartas de Gwent mais similares entre si?

Já olhamos os decks de Gwent para identificar e explorar as regras de associação entre as cartas, o que alavanca as estratégias de utilização das mesmas conhecidas pela comunidade. Neste post vamos tomar outra abordagem e buscar os pares de cartas cujas características são mais similares entre si e que, portanto, poderia fornecer algum outro tipo de estratégia ainda não explorada e/ou facilitar a nossa vida quanto à escolha das cartas que colocaremos em um deck

Motivação

Há algum tempo atrás construí um scrapper para raspar a biblioteca de decks de Gwent, de forma à usar esses dados para me ajudar a tomar melhores decisões na hora de montar meus próprios decks. Neste sentido, uma das primeiras coisas que fiz foi tentar entender os padrões de co-ocorrência das cartas de Gwent entre os decks contribuídos pela comunidade, utilizando para isso uma análise orientada à regras de associação - técnica muito utilizada em análises de carrinho de compra (i.e., market basket analysis), além de ser uma ferramenta útil na hora de uma análise exploratória de dados. Este primeiro exercício acabou sendo bastante positivo, pois consegui extrair alguns insights bastante importantes que eu não tinha visibilidade, e que acabaram melhorando a minha estratégia e experiência de jogo.

Um ponto importante daquela primeira análise é que ela olha para os padrões de co-ocorrência de cartas conhecidos e explorados pela comunidade, deixando de fora àquelas combinações de cartas que teriam o potencial de funcionar juntas mas que nunca foram testadas. Por exemplo, existe uma mecânica de envenenamento, no qual se uma carta receber este status duas vezes ela é imediatamente destruída. Nesse contexto, existem algumas cartas específicas que são usadas com uma frequência muito alta para implementar esta mecânica, ainda que existam muitas outras cartas que também o possam fazer mas que não são usualmente postas nos decks. As mecânicas implementadas por cada carta são apresentadas em sua descrição, mas existem algumas formas diferentes de descrever um mesmo tipo de mecânica além de diferenças na forma como elas são disparadas entre as as facções. Assim, identificar as cartas que têm mecânicas similares e o potencial de serem usadas juntas passa a ser uma tarefa viável se pudéssemos agrupar as cartas de acordo com os padrões de texto existente em suas descrições.

Uma forma de implementar este agrupamento através do texto é através da modelagem de tópicos, que é uma técnica de aprendizado não-supervisionado que faz uso de modelos estatísticos para encontrar tópicos abstratos que ocorrem em uma coleção de textos através das palavras que os compõem. Existem alguns modelos que podem ser implementados para esta finalidade, sendo o mais conhecido deles a LDA - Latent Dirichlet Allocation; todavia, vou utilizar este post para estudar, explorar e demonstrar as funcionalidades de um outro modelo de tópicos, o STM - Structural Topic Model (Roberts, Stewart, and Tingley (2019)). Meu objetivo com isso será utilizar este modelo para criar uma representação do quão similares as cartas são de acordo com seus padrões de texto e utilizar àquela representação para encontrar as cartas mais similares àquela que eu resolver buscar.

Antes de chegar aos objetivos finais desta análise vamos cobrir alguns pontos importantes. Iniciaremos falando um pouco sobre a aquisição dos dados, passando na sequência para uma breve análise exploratória. Começaremos a modelagem de tópicos falando um pouquinho mais da intuição por trás do STM e, então, vamos implementar tanto uma busca pela quantidade de tópicos que devemos utilizar antes de ajustar o modelo em si. A partir daí conduziremos algumas análises para o pós-processamento, entedimento dos tópicos e validação do modelo, e fecharemos então o post mostrando a aplicação do modelo para atingir os objetivos que defini anteriormente.

Carregando os Dados

# carregando os pacotes
library(tidyverse) # core
library(tidytext) # para manipular texto
library(patchwork) # para compor figuras
library(ggridges) # para o ridge plot
library(stringi) # para trabalhar com texto
library(reactable) # para tabelas interativas
library(reactablefmtr) # para ajudar com o reactable

# carregando os dados
cartas <- read_rds(file = 'data/cartas.rds')
# cartas <- read_rds(file = '_posts/2022-01-31-card-embeddings-parte-1/data/cartas.rds')

# ajustando a tabela por conta de duas cartas má registradas
cartas <- cartas %>% 
  # removendo a carta Solução Engenhosa, que aparece duas vezes por conta de diferencas
  # em seu nome em ingles
  filter(!(localizedName == 'Solução engenhosa' & name != 'Blueprint')) %>% 
  # ajustando o nome da carta Vidente, que aparece duas vezes pois existe uma na facção
  # neutra e outra na Scoia'tael, mas sao cartas diferentes
  mutate(
    localizedName = case_when(localizedName == 'Vidente' ~ paste0(localizedName, ' (', slug, ')'),
                              TRUE ~ localizedName)
  ) %>% 
  # colocando as cartas em ordem alfabetica
  arrange(localizedName)
cartas

# A tibble: 1,103 × 19
   localizedName name  short slug  rarity cardGroup type  categoryName
   <chr>         <chr> <chr> <chr> <chr>  <chr>     <chr> <chr>       
 1 A Fera        The … mon   Mons… Épica  gold      Unid… Espectro    
 2 A prática le… Prac… nor   Nort… Rara   bronze    Espe… Feitiço     
 3 A Terra das … Land… neu   Neut… Lendá… gold      Arte… Local       
 4 A Trufa Carn… The … neu   Neut… Lendá… gold      Arte… Local       
 5 Abaya         Abaya mon   Mons… Épica  gold      Unid… Necrófago   
 6 Aberrações d… Whor… syn   Synd… Épica  gold      Unid… Humano, Bil…
 7 Abominação S… Sala… syn   Synd… Rara   bronze    Unid… Fera, Mutan…
 8 Acônito       Wolf… neu   Neut… Lendá… gold      Espe… Nenhuma     
 9 Açougueiro d… Sval… ske   Skel… Comum  bronze    Unid… Humano, Cul…
10 Adaga Cerimo… Cere… neu   Neut… Lendá… gold      Estr… Estratégia  
# … with 1,093 more rows, and 11 more variables: ownable <lgl>,
#   decks <int>, craftingCost <int>, power <int>,
#   provisionsCost <int>, armour <int>, keywords <chr>, texto <chr>,
#   fluff <chr>, small <chr>, big <chr>

Análise Exploratória de Dados

Quantas cartas diferentes existem por facção?

cartas %>% 
  # contando quantidade de cartas existentes por faccao
  count(slug, name = 'n_cartas') %>% 
  # ordenando as colunas
  mutate(slug = fct_reorder(.f = slug, .x = n_cartas)) %>%
  # criando a figura
  ggplot(mapping = aes(x = n_cartas, y = slug, fill = slug)) +
  geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
  geom_text(mapping = aes(label = n_cartas), nudge_x = 10, fontface = 'bold') +
  scale_fill_manual(values = cores_por_faccao) +
  labs(
    title = 'Quantas cartas diferentes existem por facção?',
    x     = 'Quantidade de cartas'
  ) +
  theme(axis.title.y = element_blank())

Quais as diferenças nas características das cartas?

Show code

## raridade das cartas por faccao
fig_raridade <- cartas %>% 
  # contando quantidade de cartas existentes por faccao
  count(slug, rarity, name = 'n_cartas') %>% 
  # ordenando as colunas
  mutate(
    slug = fct_reorder(.f = slug, .x = n_cartas, .fun = sum, .desc = FALSE),
    rarity = fct_reorder(.f = rarity, .x = n_cartas, .fun = sum, .desc = TRUE),
  ) %>%
  # agrupando pela raridade
  group_by(slug) %>% 
  # calculando a proporcao de cartas por faccao
  mutate(
    proporcao = n_cartas / max(n_cartas)
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(y = slug, x = rarity, fill = proporcao)) +
  geom_tile(color = 'white', show.legend = FALSE) +
  geom_text(mapping = aes(label = n_cartas), color = 'white') +
  scale_fill_viridis_c(begin = 0.1, end = 0.8) +
  labs(title = 'Raridade das cartas') +
  theme(axis.title = element_blank())

# tipo de carta por faccao
fig_tipo <- cartas %>% 
  # contando quantidade de cartas existentes por faccao
  count(slug, type, name = 'n_cartas') %>% 
  # ordenando as colunas
  mutate(
    type = fct_reorder(.f = type, .x = n_cartas, .fun = sum, .desc = TRUE),
    slug = fct_reorder(.f = slug, .x = n_cartas, .fun = sum, .desc = FALSE)
  ) %>%
  # agrupando pela raridade
  group_by(slug) %>% 
  # calculando a proporcao de cartas por faccao
  mutate(
    proporcao = n_cartas / max(n_cartas)
  ) %>% 
  # completando todas as combinacoes de tipo e faccao
  complete(slug, type) %>% 
  # criando a figura
  ggplot(mapping = aes(y = slug, x = type, fill = proporcao)) +
  geom_tile(color = 'white', show.legend = FALSE) +
  geom_text(mapping = aes(label = n_cartas), color = 'white') +
  scale_fill_viridis_c(begin = 0.1, end = 0.8, na.value = 'white') +
  labs(title = 'Tipos de cartas') +
  theme(axis.title = element_blank())

# poder das cartas por faccao
fig_poder <- cartas %>% 
  # pegando apenas as cartas de unidade
  filter(type == 'Unidade') %>% 
  # ordenando as colunas
  mutate(slug = fct_reorder(.f = slug, .x = power, .fun = mean)) %>% 
  # criando a figura
  ggplot(mapping = aes(x = power, y = slug, fill = slug)) +
  geom_density_ridges(scale = 0.95, show.legend = FALSE,
                      jittered_points = TRUE,
                      position = position_points_jitter(width = 0.01, height = 0),
                      point_shape = '|', point_size = 3, point_alpha = 1, alpha = 0.7) +
  scale_fill_manual(values = cores_por_faccao)  +
  scale_x_continuous(breaks = seq(from = 0, to = 15, by = 1)) +
  labs(
    title = 'Poder das cartas do tipo Unidade',
    x     = 'Poder'
  ) +
  theme(axis.title.y = element_blank())

# poder das cartas por faccao
fig_armadura <- cartas %>% 
  # pegando apenas as cartas de unidade
  filter(type == 'Unidade') %>% 
  # ordenando as colunas
  mutate(slug = fct_reorder(.f = slug, .x = armour, .fun = mean)) %>% 
  # criando a figura
  ggplot(mapping = aes(x = armour, y = slug, fill = slug)) +
  geom_density_ridges(scale = 0.95, show.legend = FALSE,
                      jittered_points = TRUE,
                      position = position_points_jitter(width = 0.01, height = 0),
                      point_shape = '|', point_size = 3, point_alpha = 1, alpha = 0.7) +
  scale_fill_manual(values = cores_por_faccao) +
  scale_x_continuous(breaks = seq(from = 0, to = 10, by = 1)) +
  labs(
    title = 'Armadura das cartas do tipo Unidade',
    x     = 'Armadura'
  ) +
  theme(axis.title.y = element_blank())

# compondo a figura
(fig_raridade + fig_tipo) / (fig_poder + fig_armadura) +
  plot_annotation(tag_levels = 'A', tag_prefix = '(', tag_suffix = ')') & 
  theme(plot.tag = element_text(size = 10, face = 'bold'))

De que forma as categorias das cartas de Unidade variam entre facções?

Show code

cartas %>% 
  # pegando apenas as cartas de unidade
  filter(type == 'Unidade') %>% 
  # quebrando o string em tokens
  unnest_tokens(output = token, input = categoryName, to_lower = FALSE, 
                token = 'regex', pattern = ', ') %>% 
  # contando as categorias por faccao
  count(slug, token, name = 'ocorrencias') %>% 
  # contando quantas vezes cada token aparece entre as faccoes
  add_count(token, name = 'faccoes_nos_tokens') %>% 
  # contando quantas vezes as faccoes aparecem entre os tokens
  add_count(slug, name = 'tokens_nas_faccoes') %>% 
  # agrupando por faccao
  mutate(
    token = fct_reorder(.f = token, .x = faccoes_nos_tokens, .desc = FALSE),
    slug = fct_reorder(.f = slug, .x = tokens_nas_faccoes, .desc = TRUE)
  ) %>% 
  # agrupando pelo token
  group_by(token) %>% 
  # proporcao de vezes que cada token aparece entre as faccoes
  mutate(proporcao = ocorrencias / max(ocorrencias)) %>% 
  # desagrupando o dataframe
  ungroup %>% 
  # completando as combinacoes faltantes de token e faccao
  complete(token, slug) %>% 
  # criando a figura
  ggplot(mapping = aes(x = slug, y = token, fill = proporcao)) +
  geom_tile(color = 'black', show.legend = FALSE) +
  geom_text(mapping = aes(label = ocorrencias, color = proporcao > 0.5), show.legend = FALSE) +
  scale_fill_viridis_c(begin = 0.2, end = 0.9, na.value = 'white') +
  scale_color_manual(values = c('white', 'black')) +
  labs(
    title = 'Quais os tipos de personagem associados às cartas de cada facção?'
  ) +
  theme(
    axis.title = element_blank()
  )

Quais as habilidades mais comuns das cartas por facção?

Show code

cartas %>% 
  # quebrando o string em tokens
  unnest_tokens(output = token, input = keywords, to_lower = FALSE, 
                token = 'regex', pattern = ';') %>% 
  # removendo os NAs
  filter(!is.na(token)) %>%
  # contando as categorias por faccao
  count(slug, token, name = 'ocorrencias') %>% 
  # contando quantas vezes cada token aparece entre as faccoes
  add_count(token, name = 'faccoes_com_token') %>% 
  # contando quantas vezes as faccoes aparecem entre os tokens
  add_count(slug, name = 'tokens_nas_faccoes') %>% 
  # agrupando por faccao
  mutate(
    token = fct_reorder(.f = token, .x = faccoes_com_token, .desc = FALSE),
    slug = fct_reorder(.f = slug, .x = tokens_nas_faccoes, .desc = TRUE)
  ) %>% 
  # agrupando pelo token
  group_by(token) %>% 
  # proporcao de vezes que cada token aparece entre as faccoes
  mutate(proporcao = ocorrencias / max(ocorrencias)) %>% 
  # desagrupando o dataframe
  ungroup %>% 
  # completando as combinacoes faltantes de token e faccao
  complete(token, slug) %>% 
  # criando a figura
  ggplot(mapping = aes(x = slug, y = token, fill = proporcao)) +
  geom_tile(color = 'black', show.legend = FALSE) +
  geom_text(mapping = aes(label = ocorrencias, color = proporcao > 0.5), show.legend = FALSE) +
  scale_fill_viridis_c(begin = 0.2, end = 0.9, na.value = 'white') +
  scale_color_manual(values = c('white', 'black')) +
  labs(
    title = 'Quais os tipos de habilidade associados às cartas de cada facção?'
  ) +
  theme(
    axis.title = element_blank()
  )

Habilidades únicas às facções.

Show code

cartas %>% 
  # quebrando o string em tokens
  unnest_tokens(output = token, input = keywords, to_lower = FALSE, 
                token = 'regex', pattern = ';') %>% 
  # removendo os NAs
  filter(!is.na(token)) %>%
  # contando as categorias por faccao
  count(slug, token, name = 'ocorrencias') %>% 
  # calculando o tf-idf
  bind_tf_idf(term = token, document = slug, n = ocorrencias) %>% 
  # agrupando pela faccao
  group_by(slug) %>% 
  # pegando os 10 tokens com maior tf-idf
  slice_max(order_by = tf_idf, n = 10, with_ties = FALSE) %>% 
  # desagrupando
  ungroup %>% 
  # ordenando as colunas
  mutate(token = reorder_within(x = token, by = tf_idf, within = slug)) %>% 
  # criando a figura
  ggplot(mapping = aes(x = tf_idf, y = token, fill = slug)) +
  facet_wrap(~ slug, scales = 'free') +
  geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
  scale_y_reordered() +
  scale_fill_manual(values = cores_por_faccao) +
  labs(
    title = 'Quais as habilidades particulares às cartas de cada facção?',
    x     = 'TF-IDF'
  ) +
  theme(axis.title.y = element_blank())

Texto da carta.

Show code

cartas %>% 
  # quebrando o string em tokens
  unnest_tokens(output = token, input = texto, to_lower = TRUE) %>% 
  # removendo os NAs e algumas palavras que não ajudam a visualização
  filter(!is.na(token), 
         str_detect(string = token, pattern = "scoia'tael|reinos|skellige|norte|dos", negate = TRUE)) %>%
  # contando as categorias por faccao
  count(slug, token, name = 'ocorrencias') %>% 
  # calculando o tf-idf
  bind_tf_idf(term = token, document = slug, n = ocorrencias) %>% 
  # agrupando pela faccao
  group_by(slug) %>% 
  # pegando os 15 tokens com maior tf-idf
  slice_max(order_by = tf_idf, n = 15, with_ties = FALSE) %>% 
  # desagrupando
  ungroup %>% 
  # ordenando as colunas
  mutate(token = reorder_within(x = token, by = tf_idf, within = slug)) %>% 
  # criando a figura
  ggplot(mapping = aes(x = tf_idf, y = token, fill = slug)) +
  facet_wrap(~ slug, scales = 'free') +
  geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
  scale_y_reordered() +
  scale_fill_manual(values = cores_por_faccao) +
  labs(
    title = 'Quais as habilidades particulares às cartas de cada facção?',
    x     = 'TF-IDF'
  ) +
  theme(axis.title.y = element_blank())

Ajustando um modelo de tópicos

Lista de stopwords personalizada.

my_stopwords <- c('a', 'ao', 'aos', 'ate', 'cada', 'com', 'as', 'como', 'da', 'das', 
                  'de', 'dela', 'delas', 'dele', 'desta',  'deste', 'destas', 'destes',
                  'deles', 'do', 'dos', 'disso', 'e', 'es', 'em', 'esta',  'ela', 'ele',
                  'elas', 'eles', 'for', 'foi', 'la', 'lhe', 'mais', 'nas', 'nesta', 
                  'na', 'nas', 'nela', 'nele', 'no', 'nos', 'o', 'os', 'ou', 'para',
                  'por', 'pelo', 'que', 'sao', 'se', 'so', 'sos', 'sem', 'seu', 'seus',
                  'sua', 'suas', 's', 'si', 'todas', 'todos', 'tem', 'um', 'uma', 'voce',
                  'vez', 'longa', 'distancia', 'corpo', 'duas', 'dois', 'metade', 'reinos',
                  'norte', "scoia'tael", 'skellige', 'nilfgaard', 'sindicato', 'neutra',
                  'concede', 'tiver', 'seguida', 'seja', 'caso', 'faz', 'usa', 'usar',
                  'usando', 'usada', 'usado', 'tambem', 'houver', 'ha', 'pela', 'mesma',
                  'tiver', 'nao', 'nessa', 'nessas', 'nesse', 'nesses', 'qualquer', 
                  'estiver', 'entre', 'unidade', 'unidades', 'mobilizacao', 'sempre', 
                  'mesmo', 'perto', 'apos', 'quando', 'neste', 'nestes', "scoia'tel",
                  'enquanto')

Preparando os dados.

txt <- 'Esta habilidade adiciona [0-9]{2} (?:(?:de )?recrutamento[s]? ao limite )?de recrutamento (ao limite )?do (?:seu )?baralho.'

# contando ocorrencias de cada token por faccao
df_tokens <- cartas %>% 
  # removendo texto comum a todas as cartas de habilidade do lider
  mutate(
    texto = str_remove(string = texto, pattern = txt)
  ) %>% 
  # quebrando o string em tokens
  unnest_tokens(output = token, input = texto) %>% 
  # removendo acentuacao
  mutate(token = stri_trans_general(str = token, id = 'Latin-ASCII')) %>%
  # removendo stopwords
  filter(!token %in% my_stopwords) %>% 
  # removendo os digitos
  filter(str_detect(string = token, pattern = '[0-9]', negate = TRUE)) %>% 
  # substituindo algumas formas
  mutate(
    token = str_replace(string = token, pattern = '(?<=o|a)s$', replacement = ''),
    token = str_replace(string = token, pattern = '(?<=d|t)es$', replacement = 'e'),
    token = str_replace(string = token, pattern = '(?<=r)es$', replacement = ''),
    token = str_replace(string = token, pattern = 'veneno|envenenamento|envenenad[ao]', replacement = 'envenena'),
    token = str_replace(string = token, pattern = 'bloqueada|bloquei[ao]', replacement = 'bloqueio'),
    token = str_replace(string = token, pattern = 'reforcad[ao]', replacement = 'reforcada'),
    token = str_replace(string = token, pattern = 'anoes', replacement = 'anao'),
    token = str_replace(string = token, pattern = 'aleatoriamente', replacement = 'aleatorio'),
    token = str_replace(string = token, pattern = 'aleatoria', replacement = 'aleatorio'),
    ) %>% 
  # contando ocorrencia dos lemmas por carta
  count(localizedName, token, name = 'ocorrencias') 
df_tokens

# A tibble: 7,425 × 3
   localizedName              token     ocorrencias
   <chr>                      <chr>           <int>
 1 A Fera                     batalha             1
 2 A Fera                     campo               1
 3 A Fera                     fim                 1
 4 A Fera                     maior               1
 5 A Fera                     poder               1
 6 A Fera                     reforca             1
 7 A Fera                     turno               1
 8 A prática leva à perfeição aleatorio           1
 9 A prática leva à perfeição aliado              1
10 A prática leva à perfeição aumenta             1
# … with 7,415 more rows

Lematizando os tokens e contando-os.

Show code

# carregando mais pacotes
library(spacyr) # para ajudar com lematizacao

# inicializando o spacy
spacy_initialize(model = 'pt_core_news_lg')

# criando uma base de-para para lemmatizar os tokens
de_para_lemma <- distinct(df_tokens, token) %>% 
  # colocando os tokens em um vetor
  pull(token) %>% 
  # parseando os tokens para o spacyr
  spacy_parse(pos = FALSE, tag = FALSE, lemma = TRUE, dependency = FALSE) %>% 
  # passando o resultado para um tibble
  tibble %>% 
  # pegando apenas as colunas que interessam
  select(token, lemma)
  
# lemmatizando os tokens e contando ocorrencias
df_tokens <- df_tokens %>% 
  # juntando o de-para de lemmas aos tokens
  left_join(y = de_para_lemma, by = 'token') %>% 
  # contando ocorrencia dos lemmas por carta
  count(localizedName, lemma, name = 'ocorrencias')
df_tokens

Criando matriz DFM.

# criando matriz no formato document-feature matrix
df_esparsa <- df_tokens %>% 
  cast_sparse(row = localizedName, column = token, value = ocorrencias)

Procurando o valor de K.

# carregando mais pacotes
library(stm) # para a modelagem de topicos
library(furrr) # para paralelizar a busca

# setando a seed
set.seed(33)

# setando o processamento paralelo
plan(multisession)

# buscando melhor valor de K
search_K <- tibble(
  K = seq(from = 6, to = 30, by = 3)
) %>% 
  mutate(
    # rodando o STM sem nenhuma feature
    padrao = future_map(.x = K, 
                        .f = ~ stm(documents = df_esparsa, init.type = 'Spectral', 
                                   seed = 333, K = .x, verbose = FALSE),
                        .options = furrr_options(seed = TRUE)
    ),
    # passando a faccao para o content
    features = future_map(.x = K, 
                          .f = ~ stm(documents = df_esparsa, init.type = 'Spectral', 
                                     seed = 333, K = .x, content = ~ slug, data = cartas,
                                     verbose = FALSE),
                          .options = furrr_options(seed = TRUE)
    )
  ) %>% 
  pivot_longer(cols = c(padrao, features), names_to = 'tipo', values_to = 'modelos')

# setando o processamento sequencial
plan(sequential)

Extraindo métricas de avaliação.

Show code

# extraindo as metricas de avaliacao da clusterizacao
metricas <- search_K %>% 
  # calculando a exclusividade e a coerencia dos topicos
  mutate(
    exclusividade = map(.x = modelos, .f = safely(exclusivity)),
    exclusividade = map(.x = exclusividade, .f = 'result'),
    coerencia     = map(.x = modelos, .f = semanticCoherence, documents = df_esparsa),
    residuos      = map(.x = modelos, .f = checkResiduals, df_esparsa),
    residuos      = map(.x = residuos, 'dispersion')
  ) %>% 
  # dropando a coluna com os modelos
  select(-modelos) %>% 
  # desaninhando as colunas de coerencia e exclusividade
  unnest(cols = c(exclusividade, coerencia, residuos))

# plotando as metricas individualmente
fig_painel_metricas <- metricas %>%
  # passando a base para o formato longo
  pivot_longer(cols = c(exclusividade, coerencia, residuos), 
               names_to = 'metrica', values_to = 'valor') %>% 
  # dropando valores nulos
  drop_na() %>% 
  # agrupando pelo valor de K e da metrica
  group_by(K, metrica, tipo) %>% 
  # calculando o valor da media da metrica por valor de K
  summarise(
    valor = mean(x = valor, na.rm = TRUE), .groups = 'drop'
  ) %>% 
  # renomeando as metricas
  mutate(
    metrica = case_when(metrica == 'coerencia' ~ 'Coerência Semântica',
                        TRUE ~ str_to_title(string = metrica))
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(x = as.factor(K), y = valor, group = tipo, color = tipo)) +
  facet_wrap(~ metrica, scales = 'free') +
  geom_line(size = 1, show.legend = FALSE) +
  geom_point(fill = 'white', color = 'black', shape = 21, size = 3, show.legend = FALSE) +
  labs(
    caption = 'A linha azul representa o modelo que não contempla que a ocorrência das palavras pode variar dentro dos tópicos em função da identidade da facção.',
    x       = 'Quantidade de tópicos (K)',
    y       = 'Valor da métrica'
  )

# plotando as metricas de coerencia vs exclusividade
fig_coerencia_exclusividade <- metricas %>% 
  # filtrando os resultado do modelo sem content
  filter(tipo == 'padrao') %>% 
  # adicionando a sequencia do numero de topicos
  mutate(
    K = ifelse(test = K < 10, yes = paste0('0', K), no = K),
    K = paste(K, 'tópicos')
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(x = coerencia, y = exclusividade, color = K)) +
  facet_wrap(~ K) +
  geom_point(shape = 16, size = 3, show.legend = FALSE) +
  scale_color_viridis_d(direction = -1, begin = 0.2, end = 0.9) +
  labs(
    x = 'Coerência Semântica',
    y = 'Exclusividade'
  )

# criando o painel
(fig_painel_metricas / fig_coerencia_exclusividade) +
  plot_layout(heights = c(1, 2)) +
  plot_annotation(
    title = 'Quantos tópicos devemos usar?', 
    subtitle = 'A quantidade de tópicos escolhida deve atender ao melhor balanço entre uma alta coerência semântica e exclusividade',
    tag_levels = 'A', tag_prefix = '(', tag_suffix = ')') & 
  theme(plot.tag = element_text(size = 10, face = 'bold'))

Ajustando o modelo de tópicos

# setando a seed
set.seed(33)

# buscando melhor valor de K
modelo <- stm(documents = df_esparsa, init.type = 'Spectral', seed = 333, 
              K = 18, verbose = FALSE)

Entendendo os tópicos

Visualizando os topicos encontrados.

Show code

# criando figura das palavras por topicos
tidy(x = modelo, matrix = 'beta') %>% 
  # agrupando pelo topico
  group_by(topic) %>% 
  # pegando as 10 palavras com maior afinade com cada tópico
  slice_max(order_by = beta, n = 10, with_ties = FALSE) %>% 
  # criando escala numerica para colorir dentro dos topicos
  mutate(escala = beta / max(beta)) %>% 
  # desagrupando os dados
  ungroup %>% 
  # organizando as informacoes para plotar
  mutate(
    topic = ifelse(test = topic < 10, 
                   yes = paste0('Tópico 0', topic), no = paste0('Tópico', topic)),
    term = reorder_within(x = term, by = beta, within = topic)
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(x = beta, y = term, fill = escala)) +
  facet_wrap(~ topic, scales = 'free', ncol = 4) +
  geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
  scale_y_reordered() +
  scale_fill_viridis_c(begin = 0.2, end = 0.9) +
  labs(
    title    = 'Quais as palavras mais prováveis de serem observadas em cada tópico?',
    x        = expression(bold(paste('Probabilidade de ocorrência, ', beta)))
  ) +
  theme(axis.title.y = element_blank())

Visualizando os topicos encontrados - parte 2.

Show code

# extraindo os dados dos betas por topico
df_betas <- modelo$beta %>% 
  # pegando a matriz com o log das probabilidades para o beta
  pluck('logbeta') %>% 
  # parseando as matrizes para um dataframe
  map(.f = data.frame) %>% 
  # passando o log da probabilidade para probabilidade
  map(.f = exp) %>% 
  # colocando o nome nas colunas
  map(.f = ~ `colnames<-`(x = ., value = df_esparsa@Dimnames[[2]])) %>%
  # adicionando o identificador do topico a cada linha
  map(.f = mutate, topic = 1:n()) %>% 
  # renomeando os elementos da lista
  `names<-`(value = c('Monsters', 'Neutral', 'Nilfgaard', 'Northern Realms', 
                      "Scoia'tael", 'Skellige', 'Syndicate')) %>% 
  # juntando todos
  map_dfr(tibble, .id = 'slug') %>%
  # passando a base para o formato longo
  pivot_longer(cols = -c(slug, topic), names_to = 'term', values_to = 'beta')

# criando figura das palavras por topicos
df_betas %>% 
  # agrupando pelo topico e token
  group_by(topic, term) %>% 
  # calculando a media da probabilidade para aquele token naquele topico
  summarise(beta = mean(x = beta, na.rm = TRUE), .groups = 'drop') %>% 
  # agrupando pelo topico
  group_by(topic) %>% 
  # pegando as 10 palavras com maior afinade com cada tópico
  slice_max(order_by = beta, n = 10, with_ties = FALSE) %>% 
  # criando escala numerica para colorir dentro dos topicos
  mutate(escala = beta / max(beta)) %>% 
  # desagrupando os dados
  ungroup %>% 
  # organizando as informacoes para plotar
  mutate(
    topic = ifelse(test = topic < 10, 
                   yes = paste0('Tópico 0', topic), no = paste0('Tópico', topic)),
    term = reorder_within(x = term, by = beta, within = topic)
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(x = beta, y = term, fill = escala)) +
  facet_wrap(~ topic, scales = 'free', ncol = 4) +
  geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
  scale_y_reordered() +
  scale_fill_viridis_c(begin = 0.2, end = 0.9) +
  labs(
    title    = 'Quais as palavras mais prováveis de serem observadas em cada tópico?',
    x        = expression(bold(paste('Probabilidade de ocorrência, ', beta)))
  ) +
  theme(axis.title.y = element_blank())

Visualizando a proporcao de topicos.

Show code

# criando tabela com as 5 palavras mais frequentes por topico para plotarmos abaixo
df_top_palavras <- tidy(x = modelo, matrix = 'beta') %>%
  # agrupando pelo topico
  group_by(topic) %>%
  # pegando as 10 palavras com maior afinade com cada tópico
  slice_max(order_by = beta, n = 5, with_ties = FALSE) %>%
  # colocando essas palavras em um vetor
  summarise(palavras = paste0(term, collapse = ', '))

# se usarmos o content quando rodar o STM, é necessário descomentar as linhas abaixo
# df_top_palavras <- df_betas %>%
#   # agrupando pelo topico e token
#   group_by(topic, term) %>% 
#   # calculando a media da probabilidade para aquele token naquele topico
#   summarise(beta = mean(x = beta, na.rm = TRUE), .groups = 'drop') %>% 
#   # agrupando pelo topico
#   group_by(topic) %>%
#   # pegando as 10 palavras com maior afinade com cada tópico
#   slice_max(order_by = beta, n = 5, with_ties = FALSE) %>%
#   # colocando essas palavras em um vetor
#   summarise(palavras = paste0(term, collapse = ', '))

# criando a figura de prevalencia por topico
tidy(x = modelo, matrix = 'gamma') %>% 
  # agrupando pelo topico
  group_by(topic) %>% 
  # extraindo a media da probabilidade para cada topico
  # esse é o valor esperado da prevalencia do tópico
  summarise(
    media = mean(x = gamma), .groups = 'drop'
  ) %>% 
  # juntando as 5 palavras mais frequentes por topico
  left_join(y = df_top_palavras, by = 'topic') %>% 
  # reordenando as colunas
  mutate(
    topic = ifelse(test = topic < 10, yes = paste0('0', topic), no = topic),
    topic = paste('Tópico', topic),
    topic = fct_reorder(.f = topic, .x = media)
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(x = media, y = topic, fill = media)) +
  geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
  geom_text(mapping = aes(label = round(x = media, digits = 3), color = media <= 0.04), 
            nudge_x = -0.01, fontface = 'bold', show.legend = FALSE) +
  geom_text(mapping = aes(label = palavras), nudge_x = 0.005, hjust = 0) +
  scale_x_continuous(breaks = seq(from = 0, to = 0.25, by = 0.05),
                     limits = c(0, 0.27)) +
  scale_fill_viridis_c(begin = 0.2, end = 0.9) +
  scale_color_manual(values = c('black', 'white')) +
  labs(
    title = 'Quais os tópicos mais prevalentes entre as cartas?',
    x     = expression(bold(paste('Probabilidade de ocorrência, ', gamma)))
  ) +
  theme(axis.title.y = element_blank())

Visualiza correlação entre topicos.

Show code

# carregando pacotes
library(corrr) # para o plot abaixo

# criando uma plot de correlacao entre os topicos
topicCorr(model = modelo) %>% 
  # pegando a matriz de correlacao
  pluck('cor') %>% 
  # colocando o nome das dimensoes
  `rownames<-`(value = paste0('Tópico ', 1:18)) %>% 
  `colnames<-`(value = paste0('Tópico ', 1:18)) %>% 
  # passando para uma matriz do corrr
  as_cordf() %>% 
  # passando a matriz de correlacao para o formato longo
  stretch(na.rm = TRUE, remove.dups = TRUE) %>% 
  # adicionando contagem de ocorrencias de x e y para ordenar as linhas
  # e colunas da figura
  add_count(x, name = 'n_x') %>% 
  add_count(y, name = 'n_y') %>% 
  mutate(
    y = fct_reorder(.f = y, .x = n_y, .desc = TRUE),
    x = fct_reorder(.f = x, .x = n_x, .desc = TRUE)
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(x = x, y = y, fill = r)) +
  geom_tile(color = 'black') +
  geom_text(mapping = aes(label = round(x = r, digits = 2), color = abs(x = r) > 0.3), 
            fontface = 'bold', show.legend = FALSE) +
  scale_fill_gradient2(low = 'midnightblue', mid = 'white', high = 'firebrick', midpoint = 0) +
  scale_color_manual(values = c('NA', 'black')) +
  labs(
    title    = 'Qual a relação entre os tópicos identificados?',
    subtitle = 'São poucos os tópicos que compartilham algum tipo de relação'
  ) +
  theme(
    axis.title  = element_blank(),
    panel.grid  = element_blank(),
    axis.text.x = element_text(angle = 30, hjust = 1)
  )

Estimando a relacao entre topicos e metadados.

Show code

# estimando a contribuicao das features para explicar os clusters
explica_topicos <- estimateEffect(1:18 ~ 0 + slug, stmobj = modelo, 
                                  metadata = cartas, uncertainty = 'Global')

# pegando os slopes das regressoes
tidy(x = explica_topicos) %>% 
  # ajustando os dados para plotar
  mutate(
    # ajustando o nome das faccoes
    term  = str_remove(string = term, pattern = 'slug'),
    term  = str_replace_all(string = term, pattern = '\\(Intercept\\)', replacement = 'Monsters'),
    # criando codificacao de cor a partir do nome original da faccao
    cores = term,
    # ajustando o nome dos topicos
    topic = ifelse(test = topic < 10, yes = paste0('Tópico 0', topic), no = paste0('Tópico ', topic)),
    # ordenando as faccoes dentro dos topicos atraves da estimativa do slope
    term  = reorder_within(x = term, by = estimate, within = topic)
  ) %>% 
  # criando a figura
  ggplot(mapping = aes(x = estimate, y = term, fill = cores, group = 1)) +
  facet_wrap(~ topic, scales = 'free', ncol = 4) +
  geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
  scale_y_reordered() +
  scale_fill_manual(values = cores_por_faccao) +
  labs(
    title = 'Quais as facções mais relacionadas com cada tópico?',
    x     = 'Coeficientes da regressão'
  ) +
  theme(axis.title.y = element_blank())

Utilizando os tópicos

Juntando probabilidades às cartas.

# pegando a matriz gamma - as probabilidade de cada topico por documento
embeddings <- tidy(x = modelo, matrix = 'gamma') %>% 
  # juntando o prefixo topic_ ao numero de cada topico
  mutate(topic = paste0('topic_', topic)) %>% 
  # pivoteando a tabela para o formato largo
  pivot_wider(id_cols = document, names_from = topic, values_from = gamma) %>% 
  # agrupando o dataframe por linha
  rowwise() %>% 
  # extraindo o topico mais provavel por linha
  mutate(
    topK = which.max(c_across(contains('topic_'))),
    topK = ifelse(test = topK < 10, yes = paste0('Tópico 0', topK), no = paste0('Tópico ', topK))
  ) %>% 
  # desagrupando o dataframe
  ungroup %>% 
  # colocando o nome das cartas na coluna do nome do documento
  mutate(document = cartas$localizedName) %>% 
  # juntando os metadados das cartas
  left_join(y = cartas, by = c('document' = 'localizedName'))
embeddings

# A tibble: 1,103 × 38
   document    topic_1 topic_2 topic_3 topic_4 topic_5 topic_6 topic_7
   <chr>         <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>
 1 A Fera       0.0316  0.0332  0.0424 0.0106  0.0268  0.0849  0.00470
 2 A prática …  0.0167  0.0287  0.0481 0.0557  0.0341  0.0468  0.00585
 3 A Terra da…  0.0189  0.0473  0.217  0.0431  0.0249  0.0171  0.0122 
 4 A Trufa Ca…  0.0122  0.0621  0.0513 0.0582  0.0525  0.0129  0.0105 
 5 Abaya        0.0104  0.0338  0.0116 0.0229  0.00804 0.00995 0.00962
 6 Aberrações…  0.0211  0.0329  0.0166 0.00459 0.0219  0.0361  0.00431
 7 Abominação…  0.0997  0.0287  0.0440 0.00978 0.0335  0.0575  0.00421
 8 Acônito      0.0346  0.0199  0.0221 0.00995 0.00459 0.312   0.00299
 9 Açougueiro…  0.0267  0.0530  0.0191 0.00652 0.0146  0.0826  0.00914
10 Adaga Ceri…  0.0324  0.0815  0.0233 0.00861 0.0123  0.106   0.0129 
# … with 1,093 more rows, and 30 more variables: topic_8 <dbl>,
#   topic_9 <dbl>, topic_10 <dbl>, topic_11 <dbl>, topic_12 <dbl>,
#   topic_13 <dbl>, topic_14 <dbl>, topic_15 <dbl>, topic_16 <dbl>,
#   topic_17 <dbl>, topic_18 <dbl>, topK <chr>, name <chr>,
#   short <chr>, slug <chr>, rarity <chr>, cardGroup <chr>,
#   type <chr>, categoryName <chr>, ownable <lgl>, decks <int>,
#   craftingCost <int>, power <int>, provisionsCost <int>, …

Ajustando TSNE.

Show code

# carregando o pacote
library(Rtsne) # para rodar o TSNE
library(plotly) # para visualizar o TSNE

# setando a seed
set.seed(33)

# ajustando o TSNE
tsne_results <- select(embeddings, contains('topic_')) %>% 
  # passando objeto para matrix
  as.matrix() %>% 
  # ajustando tSNE
  Rtsne(check_duplicates = FALSE, perplexity = 20)

# plotando resultados do TSNE
tsne_results %>% 
  # pegando os resultado do TSNE
  pluck('Y') %>% 
  # passando para um dataframe
  data.frame %>% 
  # renomeando as colunas
  `names<-`(value = c('tsne1', 'tsne2')) %>% 
  # passando para um tibble
  tibble %>% 
  # juntando com o nome das cartas
  bind_cols(embeddings) %>% 
  # criando a figura
  plot_ly(x = ~ tsne1, y = ~ tsne2, color = ~ slug, data = ., colors = cores_por_faccao,
          mode = 'markers', type = 'scatter', marker = list(size = 7, opacity = 0.7),
          hoverinfo = 'text', 
          hovertext = ~ paste0(
            '<b>Tópico prevalente:</b> ', topK, '<br>',
            '<b>Carta:</b> ', document, '<br>',
            '<b>Raridade:</b> ', rarity, '<br>',
            '<b>Tipo:</b> ', type, '<br>',
            str_wrap(string = texto, width = 50)
            )
  ) %>% 
  layout(xaxis = list(title = 'Dimensão 1'), yaxis = list(title = 'Dimensão 2'))

Nearest neighbors.

# carregando funcoes
library(widyr) # para trabalhar em formato largo

# colocando os embeddings no formato para a funcao abaixo
df_embedding <- select(embeddings, document, contains('topic_')) %>% 
  # passando a base para o formato longo
  pivot_longer(cols = contains('topic_'), names_to = 'topico', values_to = 'probabilidade')

# criando funcao para calcular o nearest neighbors
nearest_neighbors <- function(df, carta, vizinhos) {
  
  # pegando a faccao da carta selecionada
  faccao_selecionada <- cartas %>% 
    # filtrando a carta selecionada
    filter(localizedName == carta) %>% 
    # pegando a faccao da carta
    pull(slug)
  
  # filtrando as cartas que serao comparadas
  if(faccao_selecionada != 'Neutral') {
  cartas_usaveis <- cartas %>% 
    # filtrando todas as cartas da faccao da carta selecionada
    filter(slug %in% faccao_selecionada) %>% 
    # pegando o nome das cartas
    pull(localizedName)
  # pegando todas as cartas caso a facção da carta alvo seja a neutra
  } else {
    cartas_usaveis <- pull(cartas, localizedName)
  }
  
  # calculando a similaridade de coseno entre todas as cartas e a carta alvo
  df %>%
    # filtrando apenas as cartas que serao comparadas
    filter(document %in% cartas_usaveis) %>% 
    # aplicando a funcao
    widely(
      ~ {
        # cria matriz n x m, onde n eh o numero de cartas que existem na base de dados, e m
        # é o número de tópicos identificados através do STM - o conteúdo de cada célular na
        # matriz é a probabilidade de que àquela carta esteja associada aquele tópico
        y <- .[rep(carta, nrow(.)), ]
        # no codigo abaixo o '.' representa a matriz de probablidades de cada carta possuir
        # cada tópico, e é uma matriz n x m onde o n é cada uma das cartas e o m corresponde
        # a várias colunas que representam cada um dos tópicos. Calcularemos então a similaridade
        # do conseno a carta selecionado e o embedding representado por cada outra carta:
        # - rowSums(. * y): multiplica a matriz do embedding de todos as cartas pela matriz
        # da carta selecionada
        # - sqrt(rowSums(. ^ 2)): retorna um vetor numerico, com um elemento por carta o valor
        # associado à cada carta representa o somatorio dos valores entre todas as dimensoes
        # de seu embedding (i.e., todos os topicos associado àquela carta)
        # sqrt(sum(.[token, ] ^ 2)): retorna um valor numérico, que representa o somatório dos
        # valores entre todas as dimensoes do embedding para a carta selecionada
        # (sqrt(rowSums(. ^ 2)) * sqrt(sum(.[token, ] ^ 2))): multiplica o valor do embedding
        # de cada carta pelo da carta selecionado, padronizando a similaridade calculada
        # pelo 'rowSums(. * y)'
        similaridade_coseno <- rowSums(. * y) / (sqrt(rowSums(. ^ 2)) * sqrt(sum(.[carta, ] ^ 2)))
        # coloca o resultado em uma matriz com o nome de linha vinda do nome das cartas
        #matrix(similaridade_coseno, ncol = 1, dimnames = list(x = names(similaridade_coseno)))
      },
      sort = TRUE
    )(document, topico, probabilidade) %>%
    # organizando as cartas em ordem decrescente de similaridade
    arrange(desc(item2)) %>% 
    # pegando apenas a quantidade desejada de cartas similares
    slice_max(order_by = item2, n = vizinhos) %>% 
    # juntando com metadados das cartas resultantes
    left_join(y = select(cartas, localizedName, slug, small, texto), by = c('item1' = 'localizedName'))
}

Exemplo Scoia’tael.

Show code

df_embedding %>% 
  # calculando o nearest neighbors
  nearest_neighbors(carta = 'Bruxo Gato', vizinhos = 5) %>% 
  # selecionando as colunas que vamos plotar
  select(small, item1, item2, texto) %>% 
  # adicionando o prefixo do link para a imagem
  mutate(small = paste0('https://www.playgwent.com/', small)) %>%
  # colocando os exemplos em um reactable
  reactable(
    compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'), 
    style = list(fontFamily = "Roboto", fontSize = "12px"),
    columns = list(
      small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
      item1 = colDef(name = 'Carta', maxWidth = 90),
      item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
      texto = colDef(name = 'Descrição')
    )
  )

Exemplo Northern Realms.

Show code

df_embedding %>% 
  # calculando o nearest neighbors
  nearest_neighbors(carta = 'Imortais', vizinhos = 5) %>% 
  # selecionando as colunas que vamos plotar
  select(small, item1, item2, texto) %>% 
  # adicionando o prefixo do link para a imagem
  mutate(small = paste0('https://www.playgwent.com/', small)) %>%
  # colocando os exemplos em um reactable
  reactable(
    compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'), 
    style = list(fontFamily = "Roboto", fontSize = "12px"),
    columns = list(
      small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
      item1 = colDef(name = 'Carta', maxWidth = 140),
      item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
      texto = colDef(name = 'Descrição')
    )
  )

Exemplo Nilfgaard.

Show code

df_embedding %>% 
  # calculando o nearest neighbors
  nearest_neighbors(carta = 'Artorius Viggo', vizinhos = 5) %>% 
  # selecionando as colunas que vamos plotar
  select(small, item1, item2, texto) %>% 
  # adicionando o prefixo do link para a imagem
  mutate(small = paste0('https://www.playgwent.com/', small)) %>%
  # colocando os exemplos em um reactable
  reactable(
    compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'), 
    style = list(fontFamily = "Roboto", fontSize = "12px"),
    columns = list(
      small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
      item1 = colDef(name = 'Carta', maxWidth = 140),
      item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
      texto = colDef(name = 'Descrição')
    )
  )

Exemplo Neutral.

Show code

df_embedding %>% 
  # calculando o nearest neighbors
  nearest_neighbors(carta = 'Alzur', vizinhos = 5) %>% 
  # selecionando as colunas que vamos plotar
  select(small, item1, slug, item2, texto) %>%
  # adicionando o prefixo do link para a imagem
  mutate(small = paste0('https://www.playgwent.com/', small)) %>% 
  # colocando os exemplos em um reactable
  reactable(
    compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'),
    style = list(fontFamily = "Roboto", fontSize = "12px"),
    columns = list(
      small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
      item1 = colDef(name = 'Carta', maxWidth = 140),
      slug  = colDef(name = 'Facção', maxWidth = 90),
      item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
      texto = colDef(name = 'Descrição')
    )
  )

Conclusões

Possíveis Extensões

Dúvidas, sugestões ou críticas? É só me procurar pelo e-mail ou GitHub!